home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xlsys.c < prev   
Encoding:
C/C++ Source or Header  |  1991-10-04  |  6.5 KB  |  232 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xlsys.c
  5. * RCS:          $Header: xlsys.c,v 1.7 91/03/24 22:25:38 mayer Exp $
  6. * Description:  xlisp builtin system functions
  7. * Author:       David Michael Betz
  8. * Created:      
  9. * Modified:     Fri Oct  4 04:16:49 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xlsys.c,v 1.7 91/03/24 22:25:38 mayer Exp $";
  43.  
  44.  
  45. #include "xlisp.h"
  46.  
  47. /* external variables */
  48. extern jmp_buf top_level;
  49. extern FILE *tfp;
  50.  
  51. /* external symbols */
  52. extern LVAL a_subr,a_fsubr,a_cons,a_symbol;
  53. extern LVAL a_fixnum,a_flonum,a_string,a_object,a_stream;
  54. extern LVAL a_vector,a_closure,a_char,a_ustream;
  55. extern LVAL k_verbose,k_print;
  56. extern LVAL true;
  57.  
  58. #if (defined(UNIX) || defined(WINTERP))
  59. extern LVAL a_PIPE;
  60. #endif /* (defined(UNIX) || defined(WINTERP)) */
  61.  
  62. #ifdef WINTERP
  63. extern LVAL a_XtAccelerators, a_XtTranslations, a_XEvent, a_Window, a_Pixel,
  64.   a_Pixmap, a_XImage, a_XmString, a_XmFontList, a_XT_RESOURCE, a_CALLBACKOBJ,
  65.   a_TIMEOUTOBJ, a_PIXMAP_REFOBJ, a_WIDGETOBJ, a_EVHANDLEROBJ;
  66. #endif
  67.  
  68. /* external routines */
  69. extern FILE *osaopen();
  70.  
  71. /* xload - read and evaluate expressions from a file */
  72. LVAL xload()
  73. {
  74.     unsigned char *name;
  75.     int vflag,pflag;
  76.     LVAL arg;
  77.  
  78.     /* get the file name */
  79.     name = getstring(xlgetfname());
  80.  
  81.     /* get the :verbose flag */
  82.     if (xlgetkeyarg(k_verbose,&arg))
  83.     vflag = (arg != NIL);
  84.     else
  85.     vflag = TRUE;
  86.  
  87.     /* get the :print flag */
  88.     if (xlgetkeyarg(k_print,&arg))
  89.     pflag = (arg != NIL);
  90.     else
  91.     pflag = FALSE;
  92.  
  93.     /* load the file */
  94.     return (xlload(name,vflag,pflag) ? true : NIL);
  95. }
  96.  
  97. /* xtranscript - open or close a transcript file */
  98. LVAL xtranscript()
  99. {
  100.     unsigned char *name;
  101.  
  102.     /* get the transcript file name */
  103.     name = (moreargs() ? getstring(xlgetfname()) : NULL);
  104.     xllastarg();
  105.  
  106.     /* close the current transcript */
  107.     if (tfp) osclose(tfp);
  108.  
  109.     /* open the new transcript */
  110.     tfp = (name ? osaopen(name,"w") : NULL);
  111.  
  112.     /* return T if a transcript is open, NIL otherwise */
  113.     return (tfp ? true : NIL);
  114. }
  115.  
  116. /* xtype - return type of a thing */
  117. LVAL xtype()
  118. {
  119.     LVAL arg;
  120.  
  121.     if (!(arg = xlgetarg()))
  122.     return (NIL);
  123.  
  124.     switch (ntype(arg)) {
  125.     case SUBR:        return (a_subr);
  126.     case FSUBR:        return (a_fsubr);
  127.     case CONS:        return (a_cons);
  128.     case SYMBOL:    return (a_symbol);
  129.     case FIXNUM:    return (a_fixnum);
  130.     case FLONUM:    return (a_flonum);
  131.     case STRING:    return (a_string);
  132.     case OBJECT:    return (a_object);
  133.     case STREAM:    return (a_stream);
  134.     case VECTOR:    return (a_vector);
  135.     case CLOSURE:    return (a_closure);
  136.     case CHAR:        return (a_char);
  137.     case USTREAM:    return (a_ustream);
  138.     case STRUCT:    return (getelement(arg,0));
  139. #if (defined(UNIX) || defined(WINTERP))
  140.     case XLTYPE_PIPE:        return (a_PIPE);
  141. #endif /* (defined(UNIX) || defined(WINTERP)) */
  142. #ifdef WINTERP
  143.     case XLTYPE_XtAccelerators: return (a_XtAccelerators);
  144.     case XLTYPE_XtTranslations: return (a_XtTranslations);
  145.     case XLTYPE_XEvent:        return (a_XEvent);
  146.     case XLTYPE_Window:         return (a_Window);
  147.     case XLTYPE_Pixel:          return (a_Pixel);
  148.     case XLTYPE_Pixmap:         return (a_Pixmap);
  149.     case XLTYPE_XImage:         return (a_XImage);
  150.     case XLTYPE_XmString:    return (a_XmString);
  151.     case XLTYPE_XmFontList:     return (a_XmFontList);
  152.     case XLTYPE_XT_RESOURCE:    return (a_XT_RESOURCE);
  153.     case XLTYPE_CALLBACKOBJ:    return (a_CALLBACKOBJ);
  154.     case XLTYPE_TIMEOUTOBJ:     return (a_TIMEOUTOBJ);
  155.     case XLTYPE_PIXMAP_REFOBJ:  return (a_PIXMAP_REFOBJ);
  156.     case XLTYPE_WIDGETOBJ:      return (a_WIDGETOBJ);
  157.     case XLTYPE_EVHANDLEROBJ:   return (a_EVHANDLEROBJ);
  158. #endif
  159.     default:        xlfail("bad node type");
  160.     }
  161. }
  162.  
  163. /* xbaktrace - print the trace back stack */
  164. LVAL xbaktrace()
  165. {
  166.     LVAL num;
  167.     int n;
  168.  
  169.     if (moreargs()) {
  170.     num = xlgafixnum();
  171.     n = getfixnum(num);
  172.     }
  173.     else
  174.     n = -1;
  175.     xllastarg();
  176.     xlbaktrace(n);
  177.     return (NIL);
  178. }
  179.  
  180. /* xexit - get out of xlisp */
  181. LVAL xexit()
  182. {
  183.     xllastarg();
  184.     wrapup();
  185. }
  186.  
  187. /* xpeek - peek at a location in memory */
  188. LVAL xpeek()
  189. {
  190.     LVAL num;
  191.     int *adr;
  192.  
  193.     /* get the address */
  194.     num = xlgafixnum(); adr = (int *)getfixnum(num);
  195.     xllastarg();
  196.  
  197.     /* return the value at that address */
  198.     return (cvfixnum((FIXTYPE)*adr));
  199. }
  200.  
  201. /* xpoke - poke a value into memory */
  202. LVAL xpoke()
  203. {
  204.     LVAL val;
  205.     int *adr;
  206.  
  207.     /* get the address and the new value */
  208.     val = xlgafixnum(); adr = (int *)getfixnum(val);
  209.     val = xlgafixnum();
  210.     xllastarg();
  211.  
  212.     /* store the new value */
  213.     *adr = (int)getfixnum(val);
  214.  
  215.     /* return the new value */
  216.     return (val);
  217. }
  218.  
  219. /* xaddrs - get the address of an XLISP node */
  220. LVAL xaddrs()
  221. {
  222.     LVAL val;
  223.  
  224.     /* get the node */
  225.     val = xlgetarg();
  226.     xllastarg();
  227.  
  228.     /* return the address of the node */
  229.     return (cvfixnum((FIXTYPE)val));
  230. }
  231.  
  232.